home *** CD-ROM | disk | FTP | other *** search
- unit MetaFile;
-
- interface
-
- uses Windows, SysUtils, Classes, Graphics, Shapes;
-
- type
- // Metafile shape. The shape is stored as a metafile resource.
- // The initial size is small and increases with each generation.
- // When the metafile is played, the basic colors are changed
- // the shape's main color.
- //
- // Derived classes must call LoadMetafileResource or otherwise
- // create the resource in the Metafile property.
- //
- // TMetafileShape is an abstract class (although it lacks abstract methods).
- // Concrete classes derive from TMetafileShape and provide an actual
- // metafile resource. By default, the class name is the resource name
- // (after removing the leading T).
- TMetafileShape = class(TShape)
- private
- fMetafile: TMetafile;
- fBounds: TRect;
- protected
- procedure LoadMetafileResource(const ResID, ResType: PChar);
- function ResourceType: PChar; virtual;
- function ResourceName: string; virtual;
- public
- constructor Create(Position: TPoint); override;
- destructor Destroy; override;
- procedure AfterConstruction; override;
-
- procedure Draw(Canvas: TCanvas); override;
- procedure ChangeSize; override;
- property Metafile: TMetafile read fMetafile;
- property Bounds: TRect read fBounds;
- property Left: Integer read fBounds.Left write fBounds.Left;
- property Right: Integer read fBounds.Right write fBounds.Right;
- property Top: Integer read fBounds.Top write fBounds.Top;
- property Bottom: Integer read fBounds.Bottom write fBounds.Bottom;
- end;
-
- // For example, TSplat is a metafile shape that uses the "Splat" resource.
- // See the ShapeRes.rc file for the actual resource.
- TSplat = class(TMetafileShape);
-
- implementation
-
- { TMetafileShape }
-
- procedure TMetafileShape.AfterConstruction;
- begin
- inherited;
- LoadMetafileResource(PChar(ResourceName), ResourceType);
- end;
-
- constructor TMetafileShape.Create(Position: TPoint);
- begin
- inherited;
- fMetafile := TMetafile.Create;
- end;
-
- destructor TMetafileShape.Destroy;
- begin
- FreeAndNil(fMetafile);
- inherited;
- end;
-
- // Playback a single metafile record, changing the background color to
- // the shape's own color. After playing the metafile record, restore
- // the original color, so the next time the metafile is played,
- // the same change can occur (but the shape's color will be different).
- function EnumFunc(DC: HDC; Table: PHandleTable; Emfr: PEnhMetaRecord;
- NumObjects: DWord; Self: TMetafileShape): LongBool; stdcall;
- var
- ColorPtr: ^COLORREF;
- begin
- ColorPtr := nil;
- case Emfr.iType of
- Emr_SetTextColor:
- with PEmrSetTextColor(Emfr)^ do
- if crColor = BackgroundColor then
- ColorPtr := @crColor;
- Emr_SetBkColor:
- with PEmrSetBkColor(Emfr)^ do
- if crColor = BackgroundColor then
- ColorPtr := @crColor;
- Emr_CreateBrushIndirect:
- with PEmrCreateBrushIndirect(Emfr)^ do
- if lb.lbColor = BackgroundColor then
- ColorPtr := @lb.lbColor;
- Emr_CreatePen:
- with PEmrCreatePen(Emfr)^ do
- if lopn.lopnColor = BackgroundColor then
- ColorPtr := @lopn.lopnColor;
- else
- ; // Otherwise, leave the record alone.
- end;
-
- // Set the metafile color to the shape's color.
- if ColorPtr <> nil then
- ColorPtr^ := Self.Color;
-
- Win32Check(PlayEnhMetaFileRecord(DC, Table^, Emfr^, NumObjects));
-
- // Restore the record's original color.
- if ColorPtr <> nil then
- ColorPtr^ := BackgroundColor;
- Result := True;
- end;
-
- // Draw a metafile by enumerating the metafile records.
- procedure TMetafileShape.Draw(Canvas: TCanvas);
- var
- OldPalette, NewPalette: HPalette;
- Rect: TRect;
- begin
- BoundingBox(Rect);
- Dec(Rect.Right); // Metafile bounds include right and bottom do decrement
- Dec(Rect.Bottom); // the TRect bounds, which ordinarily do not include them.
- OldPalette := 0;
- NewPalette := Metafile.Palette;
- if NewPalette <> 0 then
- begin
- OldPalette := SelectPalette(Canvas.Handle, NewPalette, True);
- RealizePalette(Canvas.Handle);
- end;
- Win32Check(EnumEnhMetaFile(Canvas.Handle, Metafile.Handle, @EnumFunc, Self, Rect));
- if NewPalette <> 0 then
- SelectPalette(Canvas.Handle, OldPalette, True);
- end;
-
- // Load a metafile resource. The resource might be in the resource DLL
- // or in the main application.
- procedure TMetafileShape.LoadMetafileResource(const ResID, ResType: PChar);
- var
- ResInstance: THandle;
- Stream: TResourceStream;
- begin
- ResInstance := FindResourceHInstance(hInstance);
- if FindResource(ResInstance, ResID, ResType) = 0 then
- ResInstance := hInstance;
-
- Stream := TResourceStream.CreateFromID(ResInstance, Integer(ResID), ResType);
- try
- Metafile.LoadFromStream(Stream);
- finally
- Stream.Free;
- end;
-
- // The initial size is square--keep the original aspect ratio by
- // shrinking the smaller dimension to match the metafile.
- if Metafile.Width > Metafile.Height then
- YSize := MulDiv(XSize, Metafile.Height, Metafile.Width)
- else
- XSize := MulDiv(YSize, Metafile.Width, Metafile.Height);
- end;
-
- // Compute the next size, trying to maintain the metafile's aspect ratio.
- procedure TMetafileShape.ChangeSize;
- var
- Delta: Integer;
- begin
- Delta := Random(DeltaDimension);
- if Metafile.Width > Metafile.Height then
- begin
- XSize := XSize + Delta;
- YSize := YSize + MulDiv(Delta, Metafile.Height, Metafile.Width);
- end
- else
- begin
- XSize := XSize + MulDiv(Delta, Metafile.Width, Metafile.Height);
- YSize := YSize + Delta;
- end;
- end;
-
- // Default resource name is the same as the class name, minus the leading 'T'.
- function TMetafileShape.ResourceName: string;
- begin
- Result := Copy(ClassName, 2, MaxInt);
- end;
-
- // Default resource type is 'Metafile'. The resource type
- // is not case sensitive.
- function TMetafileShape.ResourceType: PChar;
- begin
- Result := 'Metafile';
- end;
-
-
- initialization
- RegisterShapes([TSplat]);
- end.
-